Wizualizacja czasu

Poniższy kod działa tylko na mac os i ma sens jedynie gdy mamy niepolskie ustawienia dat i czasu a chcemy zmienić na polskie. W przypadku właściwych - polskich - ustawień nazwy dni i miesięcy powinny wyświetlać się nam po polsku. Jeśli nazwy są niepolskie kod zmieniający kolejność dni w punkcie o kalendarzach i mapach cieplnych nie będzie działał prawidłowo.

Timeline - oś czasu z wykorzystanie geom_segment

Według Dana Roama autora ksiażki “Narysuj swoje myśli” oś czasu jest modelem wizualnym ilustrującym odpowiedź na pytanie “kiedy”. Najprościej stworzyć timeline używając funkcji geom_segment() ggplot2.

Biblioteki

library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.3     ✔ readr     2.1.4
## ✔ forcats   1.0.0     ✔ stringr   1.5.0
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.0
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

Dane - Sapkowski i Martin

Użyjemy danych dotyczących dat publikacji i liczby słów w książkach z sag A. Sapkowskiego i G.R.R. Martina.

fantasy <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/fantasy.csv")

## New names:
## Rows: 12 Columns: 6
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (2): title, author dbl (4): ...1, number, rok, words
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`

head(fantasy)

Poniższy wykres jest połączeniem wykresu lizakowego (lollypop chart) z osią czasu. Lizaki - słupki a właściwie odcinki zakończone punktem - oznaczać będą daty kolejnych książek

fantasy %>% filter(author == "Martin") %>% 
  # dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
  mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'open')) + 
  geom_segment(aes(x = rok,
                     y = words,
                     xend = rok),
                 yend = 0) +
  geom_point(aes(x = rok,
                   y = words)) +
  geom_text(aes(x = rok,
                  y = words,
                  label = title),
              hjust = 1.0,vjust = 1.0,
              size  = 4) +
  scale_x_continuous() +
  theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

fantasy %>% filter(author == "Martin") %>% 
  # dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
  mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
  geom_segment(aes(x = rok, 
                     y = disloc, 
                     xend = rok), 
                 yend = 0) 

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

fantasy %>% filter(author == "Martin") %>% 
  # dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
  mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
    geom_segment(aes(x = rok, 
                     y = disloc, 
                     xend = rok), 
                 yend = 0) + 
  #rysuję oś czasu
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
    geom_text(aes(x = rok,
                  y = disloc,
                  label = title), 
              hjust = 1.0,vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = disloc)) +
  # kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
    scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

fantasy %>% filter(author == "Martin") %>% 
  # wysokość lizaków = liczba słow
ggplot() +
    geom_segment(aes(x = rok, 
                     y = words, 
                     xend = rok), 
                 yend = 0) + 
  #rysuję oś czasu
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
    geom_text(aes(x = rok,
                  y = words,
                  label = title), 
              hjust = 1.0,vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = words)) +
  # kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
    scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

Zadanie

Stwórzmy analogiczny wykres dla książek Sapkowskiego. Spróbujmy dodać daty wydania książek na osi x.

fantasy %>% filter(author == "Sapkowski") %>% 
  # dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
  mutate(disloc = c(0.5, 1, -0.5, -1, 2)) %>%
ggplot() +
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2001,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'open'))  +
   geom_segment(aes(x = rok,
                     y = disloc,
                     xend = rok),
                 yend = 0) +
  geom_point(aes(x = rok,
                   y = disloc)) +
  ggrepel::geom_text_repel(aes(x = rok,
                  y = disloc,
                  label = title),
              hjust = 1.0,vjust = 1.0,
              size  = 4) +
  scale_x_continuous(breaks = c(1994, 1995, 1996, 1997, 1999)) +
  theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2001, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 5 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

Obaj autorzy z wykorzystaniem wykresu panelowego

fantasy %>% 
ggplot() +
    geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
    geom_segment(aes(x = 1990,
                     y = 0,
                     xend = 2020,
                     yend = 0), 
                 arrow = arrow(length = unit(x = 0.2,
                                             units = 'cm'),
                               type = 'closed')) +
    ggrepel::geom_text_repel(aes(x = rok,y = words,
                  label = title),
              hjust = 1.0,
              vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = words,
                   color = author)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text_repel()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

fantasy %>% 
ggplot() +
    geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
    geom_segment(aes(x = 1990,
                     y = 0,
                     xend = 2020,
                     yend = 0), 
                 arrow = arrow(length = unit(x = 0.2,
                                             units = 'cm'),
                               type = 'closed')) +
    geom_text(aes(x = rok,y = words,
                  label = title),
              hjust = 1.0,
              vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = words,
                   color = author)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

Wykres panelowy:

fantasy %>% 
  ggplot() +
  geom_segment(aes(x = rok, y = words,xend = rok),yend = 0) + # data = data trzeba ustawić globalnie
  geom_segment(aes(x = 1993,y = 0,xend = 2012,yend = 0),
               arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
  geom_text(aes(x = rok,y = words,label = title),   hjust = 0.5,vjust = - 0.5, size  = 4) +
  geom_point(aes(x = rok,
                 y = words)) +
  scale_x_continuous(breaks = c(1994, 1995, 1996, 1997, 1999, 2000,2005, 2011)) +
  scale_y_continuous(limits = c(0, 450000)) +
  theme_bw() +
  labs(y = "słowa") +
  theme(axis.title.x = element_blank(), #usuwa podpis na osi x
       #axis.title.y = element_blank(),
        axis.text.y = element_blank(), # usuwa tekst etykiet na osi y
        text = element_text(size = 15)) +
  facet_wrap(~author, nrow =2)

## Warning in geom_segment(aes(x = 1993, y = 0, xend = 2012, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

Wykres Timline z Sapkowskim pod osią

fantasy2 <- fantasy %>%
  mutate(words_n = if_else(author == "Sapkowski", words * -1, words))

fantasy2 %>% 
ggplot() +
    geom_segment(aes(x = rok, y = words_n,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
    geom_segment(aes(x = 1990,
                     y = 0,
                     xend = 2020,
                     yend = 0), 
                 arrow = arrow(length = unit(x = 0.2,
                                             units = 'cm'),
                               type = 'closed')) +
    geom_text(aes(x = rok,y = words_n,
                  label = title),
              hjust = 1.0,
              vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = words_n,
                   color = author)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

library(ggrepel)

fantasy2 %>% 
ggplot() +
    geom_segment(aes(x = rok, y = words_n,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
    geom_segment(aes(x = 1990,
                     y = 0,
                     xend = 2020,
                     yend = 0), 
                 arrow = arrow(length = unit(x = 0.2,
                                             units = 'cm'),
                               type = 'closed')) +
    geom_text_repel(aes(x = rok,y = words_n,
                  label = title),
              hjust = 1.0,
              vjust = 1.0,
              size  = 4, 
              nudge_x = 5) +
    geom_point(aes(x = rok,
                   y = words_n,
                   color = author)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
##   a single row.

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text_repel()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

Wykres Gantta z wykorzystaniem geom_segment

Prosty przykład ramki danych z datami w formie znakowej.

timeline_data <- data.frame(event = c("Event 1", "Event 2"),
                            start = c("2020-06-06", "2020-10-01"), 
                            end   = c("2020-10-01", "2020-12-31"),
                            group = "My Events")

Na poniższym wykresie widać problem z właściwą interpretacją dat w formie napisów:

timeline_data %>%
  ggplot() +
  geom_segment(aes(y = event, #potrzebujemy esetyk y, yend i analogizni z x
                   xend = end, 
                   x= start,
                   yend = event, 
                   color = event),
               linewidth = 10) +
  theme_bw()

Dlatego zamienimy napisy na daty funkcją as.Date:

timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end)) %>%
 ggplot() +
  geom_segment(aes(y = event, 
                   xend = end, 
                   x= start, 
                   yend = event)) +
  theme_bw()

Ponieważ w moim systeme daty ustawione są na amerykańskie zmieniam ustawienie na polskie.

Ten sam wykres będzie wyglądał inaczej.

timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end)) %>%
 ggplot() +
  geom_segment(aes(y = event, 
                   xend = end, 
                   x= start, 
                   yend = event,
                   color= event), linewidth = 15) +
  theme_bw()

time <- timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end))

Gantt w jednej linii

timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end)) %>%
  ggplot() +
  geom_segment(aes(y = group, 
                   xend = end, 
                   x= start, 
                   yend = group,
                   colour = event)) +
  scale_x_date() +
  theme_bw()

Wykres Gantta rządów III RP

Dane dotyczące długości trwania poszczególnych rządów w IIIRP za wikipedią:

premierzyIIIRP <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/premierzyIIIRP.csv")

## Rows: 22 Columns: 7
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (3): nazwisko, stronnictwo, stronnictwo2
## dbl  (2): narodziny, śmierć
## date (2): start, end
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

View(premierzyIIIRP)

Jak widać w ostatniej komórce brakuje daty.

Dla uniknięcia problemów z rysowaniem linii można uzupełnić końcową komórkę w zmiennej end datą systemową funkcją Sys.Date, wewnątrz funkcji ymd z biblioteki lubridate. Komórka znajduje się w 7 kolumnie, w 22 wierszu więc robimy to tak:

premierzyIIIRP[22,7] <- lubridate::ymd(Sys.Date())

z wykorzystanim geom_segment

ggplot(premierzyIIIRP) +
  geom_segment(aes(y = stronnictwo, 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo),
               linewidth = 10) +
  scale_x_date() +
  theme_bw()

Uporządkujmy wykorzystując funkcję reorder:

x <- premierzyIIIRP %>% 
  mutate(group = "group")

premierzyIIIRP %>% 
  mutate(group = "group") %>%
ggplot() +
  geom_segment(aes(y = group, 
                   xend = end, 
                   x= start,
                   yend = group, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end),
                  linewidth = 15)) +
  scale_x_date() +
  theme_bw() -> wykres

## Warning in geom_segment(aes(y = group, xend = end, x = start, yend = group, :
## Ignoring unknown aesthetics: text

library(plotly)

## 
## Attaching package: 'plotly'

## The following object is masked from 'package:ggplot2':
## 
##     last_plot

## The following object is masked from 'package:stats':
## 
##     filter

## The following object is masked from 'package:graphics':
## 
##     layout

ggplotly(wykres, tooltip = "text")

Ustalmy etykiety na osi y na zakończenia kadencji (premierzyIIIRP$end).

ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo)) +
scale_x_date(breaks = (premierzyIIIRP$end), # ustawiamy daty na osi x na koniec danego rządu
               date_labels = "%Y") + #date_labels ustawione na rok
  theme_bw() +
  guides(colour = "none") # wyłączamy legendę

To nie jest dobre rozwiązanie bo daty się nakładają

Dlatego stworzymy wektor z unikalnymi datami rocznymi funkcjami unique i year.

lata <- as.data.frame(year(premierzyIIIRP$start))

kadencje <- unique(year(premierzyIIIRP$start))

Wektor który uzyskaliśmy ma format numeryczny.

class(kadencje)

## [1] "numeric"

Następnie zmienimy jego format na date

kadencje <- lubridate::ymd(kadencje)

## Warning: All formats failed to parse. No formats found.

plotly::ggplotly(ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo)) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%y") +
  theme_bw() +
    guides(colour = "none") 
)

z <- ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end))) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  theme_bw()

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

plotly::ggplotly(z, tooltip = "text")

y <- ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end)),
                  linewidth = 8) + # poszerzymy lini
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  scale_color_brewer(palette = "Set3", guide = "none") +
  labs(x = "",
       y="",
       title = "Rządy w III RP") +
  theme_bw()

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

y

plotly::ggplotly(y, tooltip = "text") # dodatmy tekst do argumntu tooltip

Dodamy premierów

y1<- ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end)),
                  linewidth = 10) + # poszerzymy lini
  geom_text(aes(y = reorder(stronnictwo, start), 
                   x= start,
            label = nazwisko)) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  scale_color_brewer(palette = "Set3") +
  labs(x = "",
       y="",
       title = "Rządy w III RP") +
  theme_bw()

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

y1

library(ggrepel)

ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end)),
                  linewidth = 10) + # poszerzymy lini
  geom_text_repel(aes(y = reorder(stronnictwo, start), 
                   x= start,
            label = nazwisko)) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  scale_color_brewer(palette = "Set3") +
  labs(x = "",
       y="",
       title = "Rządy w III RP") +
  theme_bw() +
  theme(panel.grid.minor = element_blank()) 

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

library(scales)

## 
## Attaching package: 'scales'

## The following object is masked from 'package:purrr':
## 
##     discard

## The following object is masked from 'package:readr':
## 
##     col_factor

library(lubridate)

Interaktywna oś czasu biblioteką timevis

#install.packages("timevis")

library(timevis)

data <- data.frame(
  id      = 1:4,
  content = c("Item one", "Item two",
              "Ranged item", "Item four"),
  start   = c("2016-01-10", "2016-01-11",
              "2016-01-20", "2016-02-14 15:00:00"),
  end     = c(NA, NA, "2016-02-04", NA)
)

timevis(data)

?timevis

Zadanie Gantt rządów w Polsce z timevis

Spróbujmy stworzyć interaktywny timeline na podstawie danych premierzyIIIRP używając timevis

premierzyIIIRP %>%
  rename(content = nazwisko,
         title = stronnictwo,
         groups = stronnictwo) %>%
timevis()

Kalendarz a’la github

Ataki środkami napadu powietrznego na Ukrainę - kalendarz mapa cieplna

Stworzymy kalendarz wzorowany na kalendarzu aktywności na githubie.

Dane dotyczące ataków powietrznych na Ukrainę z Kaggle. Według opisu automatycznie ekstraktowane z komunikatów ukraińskich.

# zbiór missile_attacks z kaggle

ataki_rakietowe <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")

## Warning: One or more parsing issues, call `problems()` on your data frame for details,
## e.g.:
##   dat <- vroom(...)
##   problems(dat)

## Rows: 2236 Columns: 17
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (9): model, launch_place, target, carrier, affected region, destroyed_d...
## dbl  (6): launched, destroyed, not_reach_goal, cross_border_belarus, back_ru...
## dttm (2): time_start, time_end
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

#zbiór missiles_and_uav 
środki <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missiles_and_uav.csv")

## Rows: 46 Columns: 12
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (11): model, category, national_origin, type, launch_platform, name, nam...
## dbl  (1): in_sevice
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

W jakim formacie będą dane z informacjami o dacie i czasie jeśli użyjemy funkcji read.csv?

test <- read.csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")

glimpse(test)

## Rows: 2,236
## Columns: 17
## $ time_start           <chr> "2025-03-15 18:30", "2025-03-14 19:30", "2025-03-…
## $ time_end             <chr> "2025-03-16 09:00", "2025-03-15 08:30", "2025-03-…
## $ model                <chr> "Shahed-136/131", "Shahed-136/131", "Iskander-M",…
## $ launch_place         <chr> "Primorsko-Akhtarsk and Chauda, Crimea and Bryans…
## $ target               <chr> "Ukraine", "Ukraine", "Kryvyi Rih", "south", "sou…
## $ carrier              <chr> "", "", "", "", "", "", "", "", "", "", "", "", "…
## $ launched             <dbl> 90, 178, 2, 1, 1, 27, 1, 1, 117, 1, 1, 1, 133, 2,…
## $ destroyed            <dbl> 47, 130, 0, 1, 1, 16, 1, 1, 74, 0, 1, 1, 98, 0, 0…
## $ not_reach_goal       <dbl> 33, 38, NA, NA, NA, 9, NA, NA, 38, NA, NA, NA, 20…
## $ cross_border_belarus <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ back_russia          <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ still_attacking      <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ affected.region      <chr> "['Chernihiv oblast', 'Kharkiv oblast', 'Odesa ob…
## $ destroyed_details    <chr> "{'Odesa oblast': 15, 'Kyiv oblast': NaN, 'Sumy o…
## $ launched_details     <chr> "", "", "", "", "", "", "", "", "", "", "", "", "…
## $ launch_place_details <chr> "", "", "", "", "", "", "", "", "", "", "", "", "…
## $ source               <chr> "kpszsu/posts/pfbid0eLGDvhV4W27vqhevdBBk37HLNhbki…

Łączymy ramkę danych z ramką opisującą typy środków napadu powietrznego żeby wyselekcjonować ataki z użyciem wybranego typu.

Wybieram model i category z ramki środki:

środki_s <- środki %>%
  select(model, category)

Wybieram czas, model, wystrzelone z ramki ataki:

ataki_s <-  ataki_rakietowe %>% 
  select(time_end, model,launched, destroyed)

Łączę lewym złączeniem (left_join)

ataki_środki <- left_join(ataki_s, środki_s)

## Joining with `by = join_by(model)`

kal <- ataki_środki %>% 
  mutate(date = as.Date(time_end)) %>%
  complete(date = seq.Date(as.Date("2022-01-01"), 
                           as.Date("2025-03-31"), 
                           by="day"))

ataki_środki <- ataki_środki %>% 
  mutate(date = as.Date(time_end)) %>%
  complete(date = seq.Date(as.Date("2022-01-01"), 
                           as.Date("2025-03-31"), 
                           by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::isoweek(date)) 

Sumy ataków według kategorii

ataki_cat <- ataki_środki %>%
  group_by(date, category) %>%
  summarise(wystrzelone = sum(launched)) %>%
  ungroup()

## `summarise()` has grouped output by 'date'. You can override using the
## `.groups` argument.

manewrujące <- ataki_cat %>%
  filter(category == "cruise missile") %>%
  select(date, wystrzelone)

df7 <- manewrujące %>%
   complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2025-03-16"), by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::epiweek(date)) 

Manewrujące

z <- ggplot(df7, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradientn(colors = c("yellow", "red4"),
                     values = scales::rescale(c(1, 115)),  # Reskalowanie pełnego zakresu
                     na.value = "gray88",
                     limits = c(1, 115)) + # wygląda na to że w 2024 nie ma na value
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"), 
                     position = "bottom") +
  theme_minimal() +
  facet_wrap(~year, ncol = 1) +
   theme(panel.grid = element_blank(),
         axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_legend(title.position = "left", 
                              label.position = "bottom",
                              keywidth = 1, 
                              nrow = 1)) +
  labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
     caption = "źródło: [Kaggle](https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine)")

z

 ggplot(df7, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "yellow", 
                      high = "red4",
                     na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() +
  scale_x_continuous( breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"), 
                     position = "top") +
  theme_minimal() +
  facet_wrap(~year, ncol = 1)

 ggplot(df7, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "yellow", 
                      high = "red4",
                     na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"), 
                     position = "bottom") +
  theme_minimal() +
  facet_wrap(~year, ncol = 1) +
   theme(panel.grid = element_blank(),
         axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_legend(title.position = "left", 
                              label.position = "bottom",
                              keywidth = 1, 
                              nrow = 1)) +
  labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
     caption = "źródło: <a href='https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine' target='_blank'>Kaggle</a>")

ggplot(df7, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "yellow", 
                      high = "red4",
                     na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"), 
                     position = "bottom") +
  theme_minimal() +
  facet_wrap(~year, ncol = 1) +
   theme(panel.grid = element_blank(),
         axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_colorbar(title.position = "left", 
                               label.position = "bottom",
                               barwidth = 10,   # Szerszy pasek skali
                               barheight = 1,   # Wysokość paska skali
                               frame.colour = "black",  # Ramka wokół skali
                               ticks.colour = "black")) +
  labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
     caption = "źródło: <a href='https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine' target='_blank'>Kaggle</a>")

miesiące <- c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru")

Balistyczne

balistyczne <- ataki_cat %>%
  filter(category == "ballistic missile") %>%
  select(date, wystrzelone)

bdf <- balistyczne %>%
   complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2025-03-16"), by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::epiweek(date))  

b <- ggplot(bdf, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "orange",
                      high ="red4",
                      na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące,
                     position = "bottom") +
  theme_gray() +
  facet_wrap(~year, ncol = 1) +
   theme(panel.grid = element_blank(),
         axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_legend(title.position = "left", 
                              label.position = "bottom",
                              keywidth = 1, 
                              nrow = 1)) +
  labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
       caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")

b <- ggplot(bdf, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "yellow",
                      high ="red4",
                      na.value = "gray") + # 
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące,
                     position = "bottom") +
  theme_minimal() +
  facet_wrap(~year, ncol = 1) +
   theme(axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_legend(title.position = "left", 
                              label.position = "bottom",
                              keywidth = 1, 
                              nrow = 1)) +
  labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
       caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")

b

ggplotly(b)

## Warning in min(x): no non-missing arguments to min; returning Inf

## Warning in max(x): no non-missing arguments to max; returning -Inf

## Warning in matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), :
## data length [365] is not a sub-multiple or multiple of the number of rows [7]

## Warning in matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow =
## TRUE): data length [365] is not a sub-multiple or multiple of the number of rows
## [7]

## Warning in matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), :
## data length [366] is not a sub-multiple or multiple of the number of rows [7]

## Warning in matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow =
## TRUE): data length [366] is not a sub-multiple or multiple of the number of rows
## [7]

## Warning in colorscale_json(trace$colorscale): A colorscale list must of elements
## of the same (non-zero) length

Kalendarz z danych o rakietach

Standadowy kalendarz

kalendarz <- data.frame(date = seq(as.Date("2025-01-01"), 
                                   as.Date("2025-12-31"), 
                                   by = "day"))  %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::epiweek(date))

kalendarz %>%
ggplot(aes(x = wday, y = week)) + 
  geom_tile(color = "grey", fill = "white", size = .5) +
  geom_text(aes(label = day)) +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) +
    guides(color = "none")

## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

Rakiety balistyczne

bdf_iso <- balistyczne %>%
   complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2025-03-16"), by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::isoweek(date))  

bdf %>% 
  filter(year == 2023) %>%
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "yellow", 
                       high = "red4", 
                     name = "liczba rakiet", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) +
    guides(color = "none") 

źró∂ło problemu?

problem <- bdf %>% 
  filter(year == 2023)

Rozwiązanie: trzeba zamienić tydzień ostatniego dnia grudnia na 53

problem <- problem %>%
  mutate(week = if_else(month == "gru" & day == 31, 53, week))

problem %>% 
  filter(year == 2023) %>%
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "yellow", 
                       high = "red4", 
                     name = "liczba rakiet", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) +
    guides(color = "none") 

To samo tylko tydzień zaczyna się w poniedziałek

Pierwszy problem:

bdf_iso %>% 
  filter(year == 2023) %>%
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "yellow", 
                       high = "red4", 
                     name = "wystrzelone", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) 

glimpse(bdf_iso)

## Rows: 901
## Columns: 8
## $ date        <date> 2022-09-28, 2022-09-29, 2022-09-30, 2022-10-01, 2022-10-0…
## $ wystrzelone <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA…
## $ year        <dbl> 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022…
## $ month       <ord> wrz, wrz, wrz, paź, paź, paź, paź, paź, paź, paź, paź, paź…
## $ months      <dbl> 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 1…
## $ wday        <ord> śro, czw, ptk, sob, ndz, pon, wto, śro, czw, ptk, sob, ndz…
## $ day         <int> 28, 29, 30, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,…
## $ week        <dbl> 39, 39, 39, 39, 39, 40, 40, 40, 40, 40, 40, 40, 41, 41, 41…

class(bdf_iso$wday)

## [1] "ordered" "factor"

levels(bdf_iso$wday)

## [1] "ndz" "pon" "wto" "śro" "czw" "ptk" "sob"

bdf_iso$wday <- factor(bdf_iso$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))

Drugi problem

bdf_iso %>% 
  filter(year == 2023) %>%
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "yellow", 
                       high = "red4", 
                     name = "wystrzelone", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) 

drugi_problem <- bdf_iso %>% 
  filter(year == 2023) 

bdf_iso$week[bdf_iso$month=="sty" & bdf_iso$week ==52] = 0

bdf_iso <- bdf_iso %>%
  mutate(week = if_else(month == "sty" & week == 52, 0, week))

mutate(week = if_else(…)): Funkcja mutate modyfikuje kolumnę week, a if_else pozwala na przypisanie wartości 0 w przypadku, gdy warunki są spełnione (miesiąc to “sty”, a numer tygodnia to 52). Warunek: month == “sty” & week == 52 sprawdza, czy w danym wierszu miesiąc to styczeń, a numer tygodnia to 52. Wartość, jeśli warunek jest spełniony: 0 Wartość, jeśli warunek nie jest spełniony: zachowuje oryginalną wartość w kolumnie week. Efekt: Dzięki temu zapisowi, zamiast bezpośredniej zmiany danych w oryginalnym zbiorze, wartości w kolumnie week zostaną zaktualizowane tylko w tych wierszach, które spełniają określony warunek. Jeśli warunek nie jest spełniony, wartość w kolumnie week pozostanie bez zmian.

bdf_iso %>% 
  filter(year == 2023) %>%
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "yellow", 
                       high = "red4", 
                     name = "wystrzelone", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) 

Zadanie domowe

Sporządźmy anlogiczny kalendarz dla ataków bezpilotowcami (UAV)

Biblioteka calendR

#install.packages("calendR")

library(calendR)

## ~~ Package calendR
## Visit https://r-coder.com/ for R tutorials ~~

# Data
set.seed(2)
data <- rnorm(365)

dat <- bdf %>% 
  filter(year == 2023) %>%
  select(wystrzelone) 

dat[is.na(dat)] <- 0

# Calendar
calendR(year = 2023,
        special.days = dat$wystrzelone,
        gradient = TRUE,
        low.col = "#FCFFDD",
        special.col = "#00AAAE",
        legend.pos = "right",
        legend.title = "Title")

Co po zajęciach

Plan minimum:

Ściągawka Lubridate

Plan dla ambitnych:

Rozdział 7 Long, J. D. (2020). Język R: Receptury: analiza danych, statystyka i przetwarzanie grafiki, (K. Sawka, Tłum.). Helion SA.

online po angielsku

rozdział 13 z Wickham, H., & Grolemund, G. (2020). Język R: Kompletny zestaw narzędzi dla analityków danych (J. Zatorska, Tłum.). Wydawnictwo Helion.

online po angielsku